home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / PIL.LQP / pil.lsp
Encoding:
Text File  |  1985-06-03  |  4.4 KB  |  114 lines
  1. ;; The following is a tiny Prolog interpreter in MacLisp
  2. ;; written by Ken Kahn and modified for XLISP by David Betz.
  3. ;; It was inspired by other tiny Lisp-based Prologs of
  4. ;; Par Emanuelson and Martin Nilsson.
  5. ;; There are no side-effects anywhere in the implementation.
  6. ;; Though it is VERY slow of course.
  7.  
  8. (defun prolog (database / goal) ;; a top-level loop for Prolog
  9.   (while (setq goal (read))
  10.     (prove (list (rename-variables goal '(0)))
  11.            '((bottom-of-environment))
  12.            database
  13.            1)))
  14.  
  15. (defun prove (list-of-goals environment database level)
  16.   ;; proves the conjunction of the list-of-goals
  17.   ;; in the current environment
  18.   (cond ((null list-of-goals)
  19.          ;; succeeded since there are no goals
  20.          (print-bindings environment environment)
  21.           ;; the user answers "y" or "n" to "More?"
  22.          (! (y-or-n-p "More?")))
  23.         (t (try-each database database
  24.                      (tail list-of-goals) (head list-of-goals)
  25.                      environment level))))
  26.  
  27. (defun try-each (database-left database goals-left goal environment level
  28.                  / assertion new-enviroment)
  29.  (cond ((null database-left)
  30.         ()) ;; fail since nothing left in database
  31.        (t (setq assertion
  32.                  ;; level is used to uniquely rename variables
  33.                 (rename-variables (head database-left)
  34.                                    (list level)))
  35.           (setq new-environment
  36.                 (unify goal (head assertion) environment))
  37.           (cond ((null new-environment) ;; failed to unify
  38.                  (try-each (tail database-left) database
  39.                            goals-left goal
  40.                            environment level))
  41.                 ((prove (append (tail assertion) goals-left)
  42.                         new-environment
  43.                         database
  44.                         (+ 1 level)))
  45.                 (t (try-each (tail database-left) database
  46.                              goals-left goal
  47.                              environment level))))))
  48.  
  49. (defun unify (x y environment / new-environment)
  50.   (setq x (value x environment))
  51.   (setq y (value y environment))
  52.   (cond ((variable-p x) (cons (list x y) environment))
  53.         ((variable-p y) (cons (list y x) environment))
  54.         ((|| (atom x) (atom y))
  55.          (cond ((equal x y) environment)
  56.                (t nil)))
  57.         (t (setq new-environment (unify (head x) (head y) environment))
  58.            (cond (new-environment (unify (tail x) (tail y) new-environment))
  59.                  (t nil)))))
  60.  
  61. (defun value (x environment / binding)
  62.   (cond ((variable-p x)
  63.          (setq binding (assoc x environment))
  64.          (cond ((null binding) x)
  65.                (t (value (nth 2 binding) environment))))
  66.         (t x)))
  67.  
  68. (defun variable-p (x) ;; a variable is a list beginning with "?"
  69.   (&& x (listp x) (eq (head x) '?)))
  70.  
  71. (defun rename-variables (term list-of-level)
  72.   (cond ((variable-p term) (append term list-of-level))
  73.         ((atom term) term)
  74.         (t (cons (rename-variables (head term)
  75.                                    list-of-level)
  76.                  (rename-variables (tail term)
  77.                                    list-of-level)))))
  78.  
  79. (defun print-bindings (environment-left environment)
  80.   (cond ((tail environment-left)
  81.          (cond ((== 0
  82.                     (nth 3 (head (head environment-left))))
  83.                 (print
  84.                  (nth 2 (head (head environment-left))))
  85.                 (princ " = ")
  86.                 (print (value (head (head environment-left))
  87.                               environment))
  88.                 (princ "\n")))
  89.          (print-bindings (tail environment-left) environment))))
  90.  
  91. ;; a sample database:
  92. (setq db '(((father jack ken))
  93.            ((father jack karen))
  94.            ((grandparent (? grandparent) (? grandchild))
  95.             (parent (? grandparent) (? parent))
  96.             (parent (? parent) (? grandchild)))
  97.            ((mother el ken))
  98.            ((mother cele jack))
  99.            ((parent (? parent) (? child))
  100.             (mother (? parent) (? child)))
  101.            ((parent (? parent) (? child))
  102.             (father (? parent) (? child)))))
  103.  
  104. ;; the following are utilities
  105. (defun assoc (key env)
  106.   (cond ((null env) nil)
  107.         ((equal (head (head env)) key) (head env))
  108.         (t (assoc key (tail env)))))
  109.  
  110. (defun y-or-n-p (prompt)
  111.   (princ prompt)
  112.   (cond ((eq (read) 'y) t)
  113.         (t nil)))
  114.